home *** CD-ROM | disk | FTP | other *** search
/ MacWorld 1999 July / Macworld (1999-07).dmg / Shareware World / Info / For Developers / Mops 3.4.sea / Mops source / System source / double next >
Text File  |  1998-10-05  |  4KB  |  150 lines
  1. \ Some double-number words
  2. \ May 98    mrh        initial version
  3.  
  4. \ This isn't the full ANSI Forth double-number word set, since I
  5. \ very much doubt we need it in all its glory for a 32-bit Forth.
  6. \ However we need some of the words for the Forth Scientific
  7. \ Library.
  8.  
  9.  
  10. \ 2SWAP is already implemented in cg6
  11.  
  12. : 2OVER
  13.     inline{ 3pick 3pick }
  14. ;
  15.  
  16.  
  17. \ The following are already implemented in pnuc1, 'cause we need them in
  18. \  the nucleus:
  19. \
  20. \  D+ D- DNEGATE
  21.  
  22. : D=  { n1_lo n1_hi n2_lo n2_hi -- b }
  23.     n1_lo n2_lo =
  24.     n1_hi n2_hi = and  ;
  25.  
  26. : D<  { n1_lo n1_hi n2_lo n2_hi -- b }
  27.     n1_hi n2_hi <>
  28.     IF      n1_hi n2_hi <
  29.     ELSE    n1_lo n2_lo u<
  30.     THEN
  31. ;
  32.  
  33. : D0<    31 a>>  nip  ;
  34.  
  35. : D0=    or 0=  ;
  36.  
  37. : DABS    dup 0< IF  dnegate  THEN  ;
  38.  
  39. : DMAX    2dup d< IF  2swap  THEN  2drop  ;
  40. : DMIN    2dup d< NIF 2swap  THEN  2drop  ;
  41.  
  42. : D>S    inline{ drop}  ;
  43.  
  44. : 2@    inline{ dup cell+ @ swap @}  ;
  45. : 2!    inline{ tuck ! cell+ !}  ;
  46. : 2>R    inline{ swap >r >r}  ;
  47. : 2R>    inline{ r> r> swap}  ;
  48. : 2R@    inline{ r> r@ swap dup >r}  ;
  49.  
  50.  
  51. : D*  { n1_lo n1_hi n2_lo n2_hi -- n3_lo n3_hi }
  52.     n1_lo n2_lo um*  n1_lo n2_hi * +  n1_hi n2_lo * +  ;
  53.  
  54.  
  55.  
  56. : D.R  { d_lo d_hi #to-right -- }
  57.     d_lo d_hi dabs
  58.     <#  #s  d_hi sign  #>
  59.     #to-right over -  spaces
  60.     type
  61. ;
  62.  
  63. : D.        \ ( n -- )
  64.     0 d.r space  ;
  65.  
  66. : D.H
  67.     base  16 -> base
  68.     swap .
  69.     -> base  ;
  70.  
  71. : UD.
  72.     <# #s #>  type  space  ;
  73.  
  74. endload
  75.  
  76.  
  77. \ Use the following if you need to, at your own risk:
  78.  
  79. :ppc_code UMD/MOD  ( uq ud1 -- ud2 ud3 )
  80.     \ unsigned quad divided by double, giving double remainder and quotient.
  81.     \ I doubt this is used much in anger, so I'm not going to bother with
  82.     \ the pre-shifting stuff, which would be a definite pain with 128 bits.
  83.  
  84.     r8        0    rSP        lwz,        \ get dividend to r8:r7:r6:r5
  85.     r7        4    rSP        lwz,
  86.     r6        8    rSP        lwz,
  87.     r5        12    rSP        lwz,
  88.     rSP        rSP    8        addi,        \ adjust rSP for what we return
  89.  
  90.     r9        64            li,
  91.     r9                    mtctr,        \ the number of iterations = 64
  92.  
  93.  
  94. \ Now for the main restoring division shift and subtract loop.
  95. \ With each shift we subtract the divisor from the top half of
  96. \  the 128-bit "register", but only use the result if it's positive.
  97. \ In this case we shift in a 1 into the low bit position.  Otherwise
  98. \  we shift in a 0.  This will be the next bit of the quotient.
  99. \ At the end of the loop, we'll have the remainder in the high
  100. \  half, and the quotient in the low half.
  101.  
  102.     r10        -1            li,            \ r10 = -1 for carry setting
  103.     r8        r8    0        addic,        \ clear carry initially
  104.  
  105. CDP                                    \ loop start
  106.     r5        r5    r5        adde,        \ here we shift the long register
  107.     r6        r6    r6        adde,        \  left one place by adding each
  108.     r7        r7    r7        adde,        \  portion to itself, with carry
  109.     r8        r8    r8        adde,
  110.     r0        r3    r7        subfc,        \ Subtract divisor from hi half
  111.     r9        r4    r8        subfe.,        \  of long register -> r9:r0
  112.  ge if,                                \ Result was positive, so we use it
  113.     r7        r0            mr,            \ move result to hi half of long reg
  114.     r8        r9            mr,
  115.     r0        r10    1        addic,        \ and set carry bit -
  116.  then,                                \ carry bit will come into the lo
  117.                                      \  bit position of the long reg on
  118.                                      \  the next shift.
  119.  
  120. dnz bc,                                \ loop
  121.  
  122. \ now we write the results.  The quotient is in the lo half of the long
  123. \  reg, but needs one more shift, bringing the carry into the lo bit.
  124. \ At the same time we get the quotient to r4:r3, where we want it.
  125.  
  126.     r3        r5    r5        adde,        
  127.     r4        r6    r6        adde,
  128.  
  129. \ The remainder is in r8:r7 - we now put it back into the memory part
  130. \  of the stack, where the original dividend came from.  As we always
  131. \  return 2 cells in registers from a code definition, we'll now
  132. \  have the remainder under the quotient, as required.
  133.  
  134.     r7        4    rSP        stw,
  135.     r8        0    rSP        stw,
  136.  
  137.                         blr,
  138.  
  139. ;ppc_code
  140.  
  141.  
  142. \ M*/ isn't complete yet, since it doesn't handle negative numbers.
  143.  
  144. : M*/  { n1_lo n1_hi n2 n3 \ lo mid hi -- n4_lo n4_hi }
  145.     n1_lo n2 m*  -> mid  -> lo
  146.     n1_hi n2 m*  mid s>d  d+  -> hi  -> mid
  147.     
  148.     lo mid hi 0  n3 0  umd/mod  2swap 2drop
  149. ;
  150.